Pascal Super Library/Pascal Super Library (CW International)(1997).bin/DELPHI32/COMPNENT/SAWIN95/SAWIN95.ZIP/Lib/32/FreeWare/ChkList.pas

Pascal/Delphi Source File | 1996-10-10 | 22KB | 770 lines

unit ChkList;

interface

uses
  {$IFDEF WIN32}
  Windows,
  {$ELSE}
  WinTypes, WinProcs, Menus,
  {$ENDIF}
  Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, Grids, DsgnIntf, TypInfo;

type
  TCheckState = (csUnchecked, csChecked, csGrayed);
  TCheckStyle = (csAutoDetect, csNew, csWin31);
  TCheckMode = (cmCheckboxClick, cmDoubleClick, cmBoth);

  TRedrawEvent = procedure(Sender: TObject; AItem : LongInt) of object;

  TStateChangedEvent = procedure(Sender : TObject; Index : Integer; State : TCheckState) of object;
  TStateChangeEvent = procedure(Sender : TObject; Index : Integer; var NewState : TCheckState) of object;

  TCheckListStrings = class(TStringList)
  private
    FOnCheckRows : TNotifyEvent;
    FOnRedraw    : TRedrawEvent;
    FSorted      : Boolean;
    procedure SetState(Index: Integer; AState: TCheckState);
    function  GetState(Index: Integer): TCheckState;
    procedure SetSorted(Value : Boolean);
  protected
    procedure ReadState(Reader : TReader);
    procedure WriteState(Writer : TWriter);
    function  Transform(const S: string; PutIt : Boolean): string;
    function  OldGet(Index: Integer): string;
    procedure OldPut(Index: Integer; const S: string);
    procedure QuickSort(L, R: Integer);
  public
    procedure DefineProperties(Filer : TFiler); override;
    function Add(const S: string): Integer; override;
    function AddObject(const S: string; AObject: TObject): Integer; override;
    procedure Delete(Index: Integer); override;
    procedure Insert(Index: Integer; const S: string); override;
    function Get(Index: Integer): string; override;
    procedure Put(Index: Integer; const S: string); override;
    procedure Sort;
    property Sorted: Boolean read FSorted write SetSorted;
    property State[Index: Integer]: TCheckState read GetState write SetState;
    property OnCheckRows: TNotifyEvent read FOnCheckRows write FOnCheckRows;
    property OnRedraw   : TRedrawEvent read FOnRedraw write FOnRedraw;
  end;

  TCheckListBox = class(TCustomGrid)
  private
    FOnStateChanged : TStateChangedEvent;
    FOnStateChange  : TStateChangeEvent;
    FCheckCtl3D     : Boolean;
    FCheckStyle     : TCheckStyle;
    FCheckMode      : TCheckMode;
    FFocusRect      : TRect;
    FItems          : TStrings;
    FIntegralHeight : Boolean;
    FItemHeight     : Integer;
    FItemIndex      : Integer;
    FMinWidth       : Integer;
    FGrayCheckMark  : Boolean;
    FShowFocusRect  : Boolean;
    procedure SetItems(Value : TStrings);
    procedure SetItemIndex(Value : Integer);
    function GetCheckState(Index: Integer): TCheckState;
    procedure SetCheckState(Index : Integer; Value : TCheckState);
    procedure SetIntegralHeight(Value : Boolean);
    procedure SetCheckCtl3D(Value : Boolean);
    procedure SetCheckStyle(Value : TCheckStyle);
    procedure SetGrayCheckMark(Value : Boolean);
    procedure SetShowFocusRect(Value : Boolean);
    procedure SetSorted(Value : Boolean);
    function  GetSorted: Boolean;
    { Private declarations }
  protected
    procedure Check(Sender : TObject);
    procedure RedrawLine(Sender : TObject; AItem: LongInt);
    procedure wmSize(var Msg: TWMSize); message WM_SIZE;
    procedure cmFontChanged(Var Msg : TMessage); message CM_FONTCHANGED;
    procedure cmEnabledChanged(Var Msg : TMessage); message CM_ENABLEDCHANGED;
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
    procedure KeyPress(var Key: Char); override;
    procedure DblClick; override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure Toggle(const Index : Integer);
    function  SetIndex(Index: Integer): Integer;
    function  NewStyle: Boolean;
    procedure CheckRows;
    procedure Resize;
    procedure DrawCell(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState); override;
    procedure SetRowHeight;
    { Protected declarations }
  public
    constructor Create(AOwner : TComponent); override;
    destructor Destroy; override;
    procedure Clear;
    property ItemIndex: Integer read FItemIndex write SetItemIndex;
    property State[Index: Integer]: TCheckState read GetCheckState write SetCheckState;
    { Public declarations }
  published
    property Align;
    property BorderStyle;
    property Enabled;
    property Font;
    property CheckCtl3D: Boolean read FCheckCtl3D write SetCheckCtl3D default True;
    property CheckMode: TCheckMode read FCheckMode write FCheckMode default cmBoth;
    property CheckStyle: TCheckStyle read FCheckStyle write SetCheckStyle default csAutoDetect;
    property Color;
    property Ctl3D;
    property DragCursor;
    property DragMode;
    property GrayCheckMark: Boolean read FGrayCheckMark write SetGrayCheckMark default False;
    property IntegralHeight: Boolean read FIntegralHeight write SetIntegralHeight default True;
    property Items: TStrings read FItems write SetItems;
    property ItemHeight: Integer read FItemHeight;
    property ParentColor;
    property ParentCtl3D;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property ShowFocusRect: Boolean read FShowFocusRect write SetShowFocusRect default True;
    property Sorted: Boolean read GetSorted write SetSorted default False;
    property TabOrder;
    property TabStop;
    property Visible;

    property OnClick;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
{$IFDEF WIN32}
    property OnStartDrag;
{$ENDIF}
    property OnStateChange: TStateChangeEvent read FOnStateChange write FOnStateChange;
    property OnStateChanged: TStateChangedEvent read FOnStateChanged write FOnStateChanged;
    { Published declarations }
  end;

implementation

function min(const x, y : integer): integer;
begin
  if x<y then result := x else result := y;
end;

function max(const x, y : integer): integer;
begin
  if x<y then result := y else result := x;
end;

{ TCheckListStrings }

function TCheckListStrings.GetState(Index: Integer): TCheckState;
Var sItem : String;
begin
  sItem := OldGet(Index);
  case sItem[1] of
   '1' : Result := csChecked;
   '2' : Result := csGrayed;
  else   Result := csUnchecked;
  end;
end;

procedure TCheckListStrings.SetState(Index : Integer; AState : TCheckState);
Var sItem : String;
begin
  sItem := Get(Index);
  case AState of
   csUnchecked : sItem := '0|' + sItem;
   csChecked   : sItem := '1|' + sItem;
   csGrayed    : sItem := '2|' + sItem;
  end;
  OldPut(Index, sItem);
end;

procedure TCheckListStrings.SetSorted(Value : Boolean);
begin
  if FSorted<>Value then
   begin
     if Value then Sort;
     FSorted := Value;
   end;
end;

procedure TCheckListStrings.QuickSort(L, R: Integer);
var
  I, J: Integer;
  P: String;
begin
  I := L;
  J := R;
  P := Get((L + R) shr 1);
  repeat
    while AnsiCompareText(Get(I), P) < 0 do Inc(I);
    while AnsiCompareText(Get(J), P) > 0 do Dec(J);
    if I <= J then
    begin
      Exchange(I, J);
      Inc(I);
      Dec(J);
    end;
  until I > J;
  if L < J then QuickSort(L, J);
  if I < R then QuickSort(I, R);
end;

procedure TCheckListStrings.Sort;
begin
  if not Sorted and (Count > 1) then
  begin
    Changing;
    BeginUpdate;
    QuickSort(0, Count - 1);
    EndUpdate;
    Changed;
    If Assigned(FOnRedraw) then FOnRedraw(Self, -1);
  end;
end;

function TCheckListStrings.Transform(const S: string; PutIt : Boolean): string;
var iPos : Integer;
begin
  Result := S;
  iPos := Pos('|', S);
  if PutIt then
   begin
     if iPos=0 then Result := '0|' + Result;
   end
  else
   begin
     if iPos>0 then Result := Copy(Result, iPos+1, Length(Result));
   end;
end;

function TCheckListStrings.Add(const S: string): Integer;
begin
  Result := inherited Add(Transform(S, True));
  if Assigned(FOnCheckRows) then FOnCheckRows(Self);
end;

function TCheckListStrings.AddObject(const S: string; AObject: TObject): Integer;
begin
  Result := inherited AddObject(Transform(S, True), AObject);
  if Assigned(FOnCheckRows) then FOnCheckRows(Self);
end;

procedure TCheckListStrings.Delete(Index: Integer);
begin
  inherited Delete(Index);
  if Assigned(FOnCheckRows) then FOnCheckRows(Self);
end;

procedure TCheckListStrings.Insert(Index: Integer; const S: string);
begin
  inherited Insert(Index, Transform(S, True));
  if Assigned(FOnCheckRows) then FOnCheckRows(Self);
end;

procedure TCheckListStrings.OldPut(Index: Integer; const S: string);
begin
  inherited Put(Index, S);
end;

function TCheckListStrings.OldGet(Index: Integer): string;
begin
  Result := inherited Get(Index);
end;

procedure TCheckListStrings.Put(Index: Integer; const S: string);
Var sOld, sNew : string;
begin
  sOld := OldGet(Index);
  sNew := Transform(S, False);
  sNew := sOld[1] + '|' + sNew;
  OldPut(Index, sNew);
  If Assigned(FOnRedraw) then FOnRedraw(Self, Index);
end;

function TCheckListStrings.Get(Index: Integer): string;
begin
  Result := OldGet(Index);
  Result := Transform(Result, False);
end;

procedure TCheckListStrings.ReadState(Reader : TReader);
var
   i  : integer;
   ct : TCheckState;
begin
  i := 0;
  Reader.ReadListBegin;
  while not Reader.EndOfList do
   begin
     ct := TCheckState(GetEnumValue(TypeInfo(TCheckState), Reader.ReadString));
     if i<Count then State[i] := ct;
     inc(i);
   end;
  Reader.ReadListEnd;
end;

procedure TCheckListStrings.WriteState(Writer : TWriter);
var
   i : Integer;
   s : string;
begin
  i := 0;
  Writer.WriteListBegin;
  for i:=0 to Count-1 do
  {$IFDEF WIN32}
   Writer.WriteString(GetEnumName(TypeInfo(TCheckState), ord(State[i])));
  {$ELSE}
   Writer.WriteString(GetEnumName(TypeInfo(TCheckState), ord(State[i]))^);
  {$ENDIF}
  Writer.WriteListEnd;
end;

procedure TCheckListStrings.DefineProperties(Filer : TFiler);

{$IFDEF WIN32}
  function DoWrite: Boolean;
  begin
    if Filer.Ancestor <> nil then
    begin
      Result := True;
      if Filer.Ancestor is TCheckListStrings then
        Result := not Equals(TCheckListStrings(Filer.Ancestor))
    end
    else Result := Count > 0;
  end;
{$ELSE}
  const DoWrite = True;
{$ENDIF}

begin
  inherited DefineProperties(Filer);
  Filer.DefineProperty('State', ReadState, WriteState, DoWrite);
end;

{ TCheckListBox }

constructor TCheckListBox.Create(AOwner : TComponent);
begin
  inherited Create(AOwner);
  FMinWidth := 13;
  Width := 121;
  Height := 97;
  Color := clWindow;
  ParentColor := False;
  RowCount := 0;
  ColCount := 1;
  FixedCols := 0;
  FixedRows := 0;
  DefaultDrawing := False;
  FItems := TCheckListStrings.Create;
  with TCheckListStrings(FItems) do
   begin
     OnCheckRows := Check;
     OnRedraw := RedrawLine;
   end;
  FItemIndex := -1;
  FCheckCtl3D := True;
  FCheckStyle := csAutoDetect;
  FIntegralHeight := True;
  FGrayCheckMark := False;
  FCheckMode := cmBoth;
  FShowFocusRect := True;
  SetRowHeight;
  CheckRows;
  inherited Options := [goThumbTracking];
end;

destructor TCheckListBox.Destroy;
begin
  FItems.Free;
  inherited Destroy;
end;

procedure TCheckListBox.Check(Sender : TObject);
begin
  CheckRows;
end;

procedure TCheckListBox.RedrawLine(Sender : TObject; AItem: LongInt);
begin
  if AItem>=0 then
   InvalidateCell(0, AItem)
  else
   Repaint;
end;

function TCheckListBox.NewStyle: Boolean;
begin
  Result := ((CheckStyle = csAutoDetect) and NewStyleControls) or (CheckStyle = csNew);
end;

function TCheckListBox.GetCheckState(Index: Integer): TCheckState;
begin
  Result := TCheckListStrings(Items).State[Index];
end;

procedure TCheckListBox.SetCheckState(Index : Integer; Value : TCheckState);
begin
  TCheckListStrings(Items).State[Index] := Value;
  InvalidateCell(0,Index);
end;

procedure TCheckListBox.SetItems(Value : TStrings);
begin
  FItems.Assign(Value);
  CheckRows;
end;

procedure TCheckListBox.Clear;
begin
  FItems.Clear;
  CheckRows;
end;

procedure TCheckListBox.SetItemIndex(Value: Integer);
begin
  if Value<>FItemIndex then
   begin
     if FItemIndex>=0 then InvalidateCell(0, FItemIndex);
     FItemIndex := Value;
     if FItemIndex>=0 then InvalidateCell(0, FItemIndex);
   end;
end;

procedure TCheckListBox.SetShowFocusRect(Value : Boolean);
begin
  if FShowFocusRect<>Value then
   begin
     FShowFocusRect := Value;
     if Focused then InvalidateCell(0, Col);
   end;
end;

procedure TCheckListbox.SetSorted(Value : Boolean);
begin
  TCheckListStrings(Items).Sorted := Value;
end;

function TCheckListbox.GetSorted: Boolean;
begin
  Result := TCheckListStrings(Items).Sorted;
end;

procedure TCheckListbox.Resize;
Var iOffs, iRows : integer;
begin
  iOffs := 0;
  iRows := max(1, Height div DefaultRowHeight);
  if BorderStyle=bsSingle then
   begin
     inc(iOffs, 2);
     if Ctl3D then inc(iOffs, 2);
   end;
  Height := iRows * DefaultRowHeight + iOffs;
end;

procedure TCheckListBox.SetIntegralHeight(Value : Boolean);
begin
  if Value<>FIntegralHeight then
   begin
     if Value then Resize;
     FIntegralHeight := Value;
   end;
end;

procedure TCheckListBox.SetCheckCtl3D(Value : Boolean);
begin
  if FCheckCtl3D<>Value then
   begin
     FCheckCtl3D := Value;
     Repaint;
   end;
end;

procedure TCheckListBox.SetGrayCheckMark(Value : Boolean);
begin
  if FGrayCheckMark<>Value then
   begin
     FGrayCheckMark := Value;
     Repaint;
   end;
end;

procedure TCheckListBox.SetCheckStyle(Value : TCheckStyle);
begin
  if FCheckStyle<>Value then
   begin
     FCheckStyle := Value;
     Repaint;
   end;
end;

procedure TCheckListBox.CheckRows;
begin
  FItemIndex := -1;
  if RowCount<>Items.Count then
   begin
     if Items.Count>0 then
      RowCount := Items.Count
     else
      RowCount := 1;
   end
  else
   Invalidate;
end;

procedure TCheckListbox.SetRowHeight;
var
  ScreenDC: HDC;
  FontSize: Integer;
begin
  ScreenDC := GetDC(0);
  try
    FontSize := MulDiv(Font.Size, GetDeviceCaps(ScreenDC, LOGPIXELSY), 72);
    FItemHeight := max(FMinWidth, MulDiv(FontSize, 120, 100)+3);
    DefaultRowHeight := FItemHeight;
  finally
    ReleaseDC(0, ScreenDC);
  end;
end;

procedure TCheckListBox.wmSize(var Msg: TWMSize);
begin
  inherited;
  if IntegralHeight then Resize;
  DefaultColWidth := ClientWidth;
end;

procedure TCheckListBox.cmFontChanged(Var Msg : TMessage);
begin
  inherited;
  SetRowHeight;
  if IntegralHeight then Resize;
end;

procedure TCheckListBox.cmEnabledChanged(Var Msg : TMessage);
begin
  inherited;
  Repaint;
end;

procedure TCheckListBox.Toggle(const Index : Integer);
Var NewState : TCheckState;
begin
  if Index=-1 then Exit;
  if State[Index]=csUnchecked then
   NewState := csChecked
  else
   NewState := csUnchecked;
  if Assigned(FOnStateChange) then FOnStateChange(Self, Index, NewState);
  State[Index] := NewState;
  if Assigned(FOnStateChanged) then FOnStateChanged(Self, Index, NewState);
end;

procedure TCheckListBox.KeyPress(var Key: Char);
begin
  inherited KeyPress(Key);
  if Key=#32 then Toggle(ItemIndex);
end;

function TCheckListBox.SetIndex(Index : Integer): Integer;
begin
  if Items.Count>0 then Result := Index else Result := -1;
end;

procedure TCheckListBox.KeyDown(var Key: Word; Shift: TShiftState);
begin
  inherited KeyDown(Key, Shift);
  if Items.Count = 0 then Exit;
  case Key of
    VK_HOME:
      begin
        ItemIndex := SetIndex(0);
        Exit;
      end;
    VK_END:
      begin
        ItemIndex := SetIndex(Items.Count-1);
        Exit;
      end;
    VK_UP:
      begin
        if ItemIndex>0 then ItemIndex := ItemIndex-1;
        Exit;
      end;
    VK_DOWN:
      begin
        if ItemIndex<Items.Count-1 then ItemIndex := SetIndex(ItemIndex+1);
        Exit;
      end;
  end;
end;

procedure TCheckListBox.DblClick;
begin
  inherited DblClick;
  if (CheckMode=cmBoth) or (CheckMode=cmDoubleClick) then Toggle(ItemIndex);
end;

procedure TCheckListBox.MouseDown(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
begin
  inherited MouseDown(Button, Shift, X, Y);
  ItemIndex := SetIndex(Row);
  if (X<=ItemHeight) and ((CheckMode=cmBoth) or (CheckMode=cmCheckboxClick)) then Toggle(Row);
end;

procedure TCheckListBox.DrawCell(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState);
var
   RectCheck      : TRect;
   OldColor,
   OldPenColor    : TColor;
   pText          : PChar;

   procedure DrawCheckMark;
   var
      cOldColor : TColor;
      iOldWidth,
      Halfy, i,
      x, y      : Integer;
   begin
     with Canvas do
      begin
        InflateRect(RectCheck, -3, -3);
        cOldColor := Pen.Color;
        iOldWidth := Pen.Width;
        if (State[ARow]=csGrayed) and GrayCheckMark then
         Pen.Color := clBtnShadow
        else
         Pen.Color := clBlack;
        Pen.Width := 1;
        with RectCheck do
         begin
           if NewStyle then
            begin
              { Draw the real 95 style checkmark }
              halfy := top+(bottom-top) div 2 + 1;
              for i:=0 to 2 do
               begin
                 PolyLine([Point(left,halfy-i), Point(left+2, halfy+2-i)]);
                 PolyLine([Point(left+2, halfy+2-i), Point(left+7, halfy-3-i)]);
               end;
            end
           else
            begin
              if CheckCtl3D then
               begin
                 { Draw a fat cross }
                 PolyLine([Point(left,top), Point(right, bottom)]);
                 PolyLine([Point(left+1,top), Point(right, bottom-1)]);
                 PolyLine([Point(left,top+1), Point(right-1, bottom)]);
                 PolyLine([Point(left,bottom-1), Point(right, top-1)]);
                 PolyLine([Point(left,bottom-2), Point(right-1, top-1)]);
                 PolyLine([Point(left+1,bottom-1), Point(right, top)]);
               end
              else
               begin
                 if State[ARow]=csGrayed then
                  begin
                    for x:=0 to right-left+1 do
                     for y:=0 to bottom-top+1 do
                      if ((x mod 2=0) and (y mod 2<>0)) or
                         ((x mod 2<>0) and (y mod 2=0)) then
                       Pixels[left-1+x,top-1+y] := clBlack;
                  end
                 else
                  begin
                    { Draw a thin cross }
                    PolyLine([Point(left-1,top-1), Point(right+1, bottom+1)]);
                    PolyLine([Point(left-1,bottom), Point(right+1, top-2)]);
                  end;
               end;
            end;
         end;
      end;
   end;

begin
  CopyRect(RectCheck, ARect);
  RectCheck.left := ((ARect.Bottom-ARect.Top) - (FMinWidth)) div 2;
  RectCheck.top := ARect.top + ((ARect.Bottom-ARect.Top) - (FMinWidth)) div 2;
  RectCheck.bottom := RectCheck.top + FMinWidth;
  RectCheck.right := RectCheck.left + FMinWidth;
  with Canvas do
   begin
     Font := Self.Font;
     Brush.Color := Color;
     if ItemIndex=ARow then
      begin
        Font.Color := clHighlightText;
        Brush.Color := clHighlight;
      end;
     FillRect(ARect);
     if Items.Count>0 then
      begin
        OldColor := Brush.Color;
        OldPenColor := Pen.Color;
        if CheckCtl3D then
         begin
           with RectCheck do
            begin
              Pen.Color := clBtnShadow;
              PolyLine([Point(left, bottom-1), Point(left, top), Point(right, top)]);
              Pen.Color := clBlack;
              PolyLine([Point(left+1, bottom-2), Point(left+1, top+1), Point(right-1, top+1)]);
              Pen.Color := clBtnFace;
              PolyLine([Point(right-2, top+1), Point(right-2, bottom-2), Point(left, bottom-2)]);
              Pen.Color := clBtnHighlight;
              PolyLine([Point(left, bottom-1), Point(right-1, bottom-1), Point(right-1, top-1)]);
            end;
         end
        else
         begin
           if NewStyle then Pen.Color := clBtnShadow;
           Rectangle(RectCheck.left+1, RectCheck.top+1, RectCheck.right-1, RectCheck.bottom-1);
         end;
        if (State[ARow]=csGrayed) and (NewStyle or ((not NewStyle) and CheckCtl3D)) then
         Brush.Color := clBtnFace
        else
         Brush.Color := clWindow;
        InflateRect(RectCheck, -2, -2);
        FillRect(RectCheck);
        InflateRect(RectCheck, 2, 2);
        if State[ARow]<>csUnchecked then DrawCheckMark;
        Brush.Color := OldColor;
        Pen.Color := OldPenColor;
      end;
     inc(ARect.left, ARect.bottom-ARect.top);
     if Items.Count>0 then
      begin
        pText := StrAlloc(Length(Items[ARow])+1);
        try
          StrPCopy(pText, Items[ARow]);
          if not Enabled then Font.Color := clBtnShadow;
          DrawText(Handle, pText, Length(Items[ARow]), ARect, DT_SINGLELINE or DT_VCENTER or DT_LEFT);
        finally
          StrDispose(pText);
        end;
      end;
     if Focused and ((ItemIndex=ARow) or ((ItemIndex=-1) and (Items.Count=0))) then
      begin
        dec(ARect.left, ARect.bottom-ARect.top);
        FFocusRect := ARect;
        if FShowFocusRect then DrawFocusRect(FFocusRect);
      end;
   end;
end;

end.